home *** CD-ROM | disk | FTP | other *** search
/ Deutsche Edition 1 / Deutsche Edition 1.iso / amok / 081-090 / amok85 / trechner / function.mod < prev    next >
Text File  |  1993-11-04  |  10KB  |  303 lines
  1. (*--------------------------------------------------------------------------
  2.   :Program.    function.mod
  3.   :Contents.   Funktionsparser
  4.   :Author.     Frank Lömker
  5.   :Copyright.  FreeWare, siehe Dok-File für TRechner
  6.   :Language.   Modula-2
  7.   :Translator. M2Amiga V4.1d
  8.   :History.    V1.0, [Frank Lömker] 01-Mar-93
  9.   :Bugs.       keine bekannt
  10. --------------------------------------------------------------------------*)
  11.  
  12. IMPLEMENTATION MODULE function;
  13. (*$ DEFINE FFP:=TRUE DEFINE LONG:=FALSE *)
  14.  
  15. (*$ StackParms:=FALSE StackChk:=FALSE RangeChk:=FALSE OverflowChk:=FALSE
  16.     CaseChk:=FALSE ReturnChk:=FALSE EntryClear:=FALSE LargeVars:=FALSE
  17.     Volatile:=FALSE *)
  18.  
  19. FROM SYSTEM IMPORT ADR,ADDRESS;
  20. FROM String IMPORT Length,Occurs,CapString;
  21. FROM Conversions IMPORT StrToVal;
  22. FROM (*$ IF FFP *)     MathTrans
  23.      (*$ ELSIF LONG *) MathIEEEDoubTrans
  24.      (*$ ELSE *)       MathIEEESingTrans (*$ ENDIF *)
  25.      IMPORT Sin,Cos,Tan,Sqrt,Log,Pow,Exp,Atan,Asin,Acos,Tanh,Sinh,Cosh,Log10;
  26. FROM (*$ IF FFP *)     FFPConversions
  27.      (*$ ELSIF LONG *) LongRealConversions
  28.      (*$ ELSE *)       RealConversions    (*$ ENDIF *) IMPORT StrToReal;
  29.  
  30. (*$ IF FFP *)
  31.   CONST factMax=20.0;  (* FFP *)
  32.         winMax=102900.0;
  33.         expMax=43.66;
  34. (*$ ELSIF LONG *)
  35.   CONST factMax=170.0;  (* LONGREAL *)
  36.         winMax=10000000000000.0;
  37.         expMax=709.78;
  38. (*$ ELSE *)
  39.   CONST factMax=34.0;  (* REAL *)
  40.         winMax=10000000000000.0;
  41.         expMax=88.72;
  42. (*$ ENDIF *)
  43.  
  44. PROCEDURE calcex (ex:ARRAY OF CHAR;x:REAL;VAR y:REAL;VAR error:SHORTINT);
  45.  
  46. PROCEDURE summand():REAL; FORWARD;
  47. PROCEDURE faktor():REAL; FORWARD;
  48. PROCEDURE potenz():REAL; FORWARD;
  49.  
  50. VAR sym,pos:INTEGER;
  51.     ch:CHAR;
  52.     wert:REAL;
  53.     einfach:ARRAY [0..20] OF CHAR;
  54.     mehrfach:ARRAY [0..100] OF CHAR;
  55.  
  56.   PROCEDURE getch;
  57.   BEGIN
  58.     REPEAT
  59.       IF pos<=Length(ex) THEN
  60.         ch:=ex[pos];
  61.         INC(pos);
  62.       ELSE
  63.         ch:=0C;
  64.       END;
  65.     UNTIL ch#" ";
  66.   END getch;
  67.  
  68.   PROCEDURE getsym;
  69.   VAR anz,stelle:INTEGER;
  70.       wert2:LONGINT;
  71.       mehr:ARRAY [0..20] OF CHAR;
  72.       err,signed:BOOLEAN;
  73.       altch:CHAR;
  74.   BEGIN
  75.     altch:=ch;
  76.     wert:=0.0; mehr:="";
  77.     anz:=0;
  78.     WHILE (einfach[anz]#ch) AND (anz<=9) DO
  79.       INC(anz); END;
  80.     IF (anz<=9) AND ( (ex[pos]<"A") OR (ex[pos]>"Z") OR (anz<8) ) THEN
  81.       sym:=anz; getch;
  82.     ELSIF ch>="A" THEN    (* Funktion (mehrfach) ? *)
  83.       stelle:=0;
  84.       WHILE (ch>="A") AND (ch<="Z") AND (stelle<20) DO
  85.         mehr[stelle]:=ch;
  86.         INC (stelle);
  87.         getch;
  88.       END;
  89.       mehr[stelle]:=0C;
  90.       sym:=Occurs(mehrfach,0,mehr,FALSE);
  91.       IF (sym=-1) OR (stelle<2) THEN sym:=-1;     (* Fehler *)
  92.               ELSE
  93.                 stelle:=sym+Length(mehr);
  94.                 IF (mehrfach[sym-1]=" ") AND (mehrfach[stelle]=" ") THEN
  95.                   sym:=sym DIV 5+11;
  96.                 ELSE sym:=-1; END;    (* Fehler *)
  97.               END;
  98.     ELSE    (* Zahl ? *)
  99.       stelle:=0; anz:=10;  (* = Basis *)
  100.       IF ch="$" THEN
  101.         anz:=16; getch;
  102.       ELSIF ch="%" THEN
  103.         anz:=2; getch;
  104.       END;
  105.       WHILE ((ch=".") OR ((ch>="0") AND (ch<="9")) OR
  106.                          ((ch>="A") AND (ch<="F")) ) AND (stelle<20) DO
  107.         mehr[stelle]:=ch;
  108.         INC(stelle);
  109.         getch;
  110.       END;
  111.       mehr[stelle]:=0C;
  112.       IF stelle=0 THEN sym:=-1;     (* Fehler *)
  113.       ELSE
  114.         sym:=10;
  115.         IF anz=10 THEN
  116.           StrToReal (mehr,wert,err);
  117.         ELSE
  118.           StrToVal (mehr,wert2,signed,anz,err);
  119.           IF wert2<0 THEN sym:=-1;
  120.                      ELSE wert:=REAL(wert2); END;
  121.         END;
  122.         IF err THEN sym:=-1; END;
  123.       END;
  124.     END;
  125.     IF (sym=-1) AND (altch#0C) THEN error:=wrongSym; END;
  126.   END getsym;
  127.  
  128.   PROCEDURE expression():REAL;
  129.   VAR neuwert,geswert:REAL;
  130.       osym:INTEGER;
  131.   BEGIN
  132.     CASE sym OF
  133.        3: getsym; geswert:=summand();  (* + *)
  134.       |4: getsym; geswert:=-summand(); (* - *)
  135.       ELSE geswert:=summand();
  136.     END;
  137.     WHILE (sym=3) OR (sym=4) DO  (* +,- *)
  138.       osym:=sym; getsym;
  139.       neuwert:=summand();
  140.       IF osym=3 THEN geswert:=geswert+neuwert;
  141.                 ELSE geswert:=geswert-neuwert; END;
  142.     END;
  143.     RETURN geswert;
  144.   END expression;
  145.  
  146.   PROCEDURE summand():REAL;
  147.   VAR neuwert,geswert:REAL;
  148.       osym:INTEGER;
  149.   BEGIN
  150.     geswert:=potenz();
  151.     WHILE (sym=5) OR (sym=6) DO  (* *,/ *)
  152.       osym:=sym; getsym;
  153.       neuwert:=potenz();
  154.       IF osym=5 THEN geswert:=geswert*neuwert;
  155.                 ELSE
  156.                   IF neuwert=0.0 THEN error:=Fehler
  157.                                  ELSE geswert:=geswert/neuwert; END;
  158.                 END;
  159.     END;
  160.     RETURN geswert;
  161.   END summand;
  162.  
  163.   PROCEDURE potenz():REAL;
  164.   VAR neuwert,geswert:REAL;
  165.       osym:INTEGER;
  166.   BEGIN
  167.     geswert:=faktor();
  168.     WHILE sym=7 DO               (* ^ *)
  169.       getsym;
  170.       neuwert:=faktor();
  171.       IF (geswert=0.0) AND (neuwert<=0.0) THEN        (* 0^(-ZAHL) *)
  172.         error:=Fehler
  173.       ELSE
  174.         IF (geswert<0.0) THEN                      (* -ZAHL^ZAHL *)
  175.           IF (neuwert=REAL(INTEGER(neuwert))) THEN (* -ZAHL^n *)
  176.             IF (ODD(INTEGER(neuwert))) THEN        (* -ZAHL^(n ungrade) *)
  177.               geswert:=-(Pow(geswert,neuwert))
  178.             ELSE
  179.               geswert:=Pow(geswert,neuwert);
  180.             END;
  181.           ELSE
  182.             error:=Fehler;
  183.           END;
  184.         ELSE
  185.           geswert:=Pow(geswert,neuwert);
  186.         END;
  187.       END;  (* IF (geswert=0.0) *)
  188.     END;  (* WHILE *)
  189.     RETURN geswert;
  190.   END potenz;
  191.  
  192.   PROCEDURE Fact (x:REAL):REAL;
  193.   VAR anz:INTEGER;
  194.   BEGIN
  195.     IF (x>factMax) OR (x<0.0) OR (x#REAL(LONGINT(x))) THEN
  196.       error:=Fehler; RETURN x;
  197.     END;
  198.     anz:=INTEGER(x);
  199.     IF anz<2 THEN RETURN 1.0; END;
  200.     x:=1.0;
  201.     REPEAT
  202.       x:=x*REAL(anz);
  203.       DEC (anz);
  204.     UNTIL anz<2;
  205.     RETURN x;
  206.   END Fact;
  207.  
  208.   PROCEDURE faktor():REAL;
  209.   VAR neuwert:REAL;
  210.       osym:INTEGER;
  211.   BEGIN
  212.     CASE sym OF
  213.         0: neuwert:=x;           (* x *)
  214.            getsym;
  215.       | 1: getsym;               (* ( *)
  216.            neuwert:=expression();
  217.            IF sym=2 THEN getsym;
  218.            ELSIF error=noFehler THEN error:=Klammerzu; END;
  219.       | 8: neuwert:=e;
  220.            getsym;
  221.       | 9: neuwert:=pi;
  222.            getsym;
  223.       |10: neuwert:=wert;        (* Zahl *)
  224.            getsym;
  225.       |11..29: osym:=sym;         (* Funkionen *)
  226.            getsym;
  227.            IF sym=1 THEN       (* ( *)
  228.              getsym;
  229.              neuwert:=expression();
  230.              IF sym=2 THEN getsym;
  231.              ELSIF error=noFehler THEN error:=Klammerzu; END;
  232.              IF error=noFehler THEN
  233.                CASE osym OF
  234.                   11: IF neuwert>winMax THEN error:=Fehler;      (* sin *)
  235.                                         ELSE neuwert:=Sin(neuwert); END;
  236.                  |12: IF neuwert>winMax THEN error:=Fehler;      (* cos *)
  237.                                         ELSE neuwert:=Cos(neuwert); END;
  238.                  |13: IF neuwert>winMax THEN error:=Fehler;      (* tan *)
  239.                                         ELSE neuwert:=Tan(neuwert); END;
  240.                  |14: IF neuwert<=0.0 THEN error:=Fehler;        (* LN *)
  241.                                       ELSE neuwert:=Log(neuwert); END;
  242.                  |15: IF neuwert<0.0 THEN error:=Fehler;         (* sqrt *)
  243.                                      ELSE neuwert:=Sqrt(neuwert); END;
  244.                  |16: neuwert:=ABS(neuwert);                     (* ABS *)
  245.                  |17: IF neuwert>expMax THEN error:=Fehler;      (* exp *)
  246.                                         ELSE neuwert:=Exp(neuwert); END;
  247.                  |18: neuwert:=Atan(neuwert);                    (* ArcTan *)
  248.                  |19: IF (neuwert<-1.0) OR (neuwert>1.0) THEN error:=Fehler;
  249.                           ELSE neuwert:=Asin(neuwert); END;      (* ArcSin *)
  250.                  |20: IF (neuwert<-1.0) OR (neuwert>1.0) THEN error:=Fehler;
  251.                           ELSE neuwert:=Acos(neuwert); END;      (* ArcCos *)
  252.                  |21: neuwert:=Tanh(neuwert);                    (* TanH *)
  253.                  |22: neuwert:=Sinh(neuwert);                    (* SinH *)
  254.                  |23: neuwert:=Cosh(neuwert);                    (* CosH *)
  255.                  |24: neuwert:=(neuwert/pi*180.0);               (* RToD *)
  256.                  |25: neuwert:=(neuwert/180.0*pi);               (* DToR *)
  257.                  |26: IF neuwert<0.0 THEN neuwert:=-1.0;         (* SGN *)
  258.                       ELSIF neuwert>0.0 THEN neuwert:=1.0
  259.                       ELSE neuwert:=0.0; END;
  260.                  |27: neuwert:=Fact(neuwert);                    (* Fact *)
  261.                  |28: IF neuwert<=0.0 THEN error:=Fehler;        (* Log *)
  262.                                       ELSE neuwert:=Log10(neuwert); END;
  263.                  |29: IF neuwert>2147000000.0 THEN error:=Fehler;
  264.                       ELSE neuwert:=REAL(LONGINT(neuwert)); END; (* INT *)
  265.                END;  (* CASE osym *)
  266.              END;  (* IF error:=noFehler *)
  267.            ELSE
  268.              error:=Klammerauf;
  269.            END;
  270.     ELSE
  271.       error:=wrongSym;
  272.     END;  (* CASE sym *)
  273.     RETURN neuwert;
  274.   END faktor;
  275.  
  276. BEGIN
  277.   y:=0.0;
  278.   einfach:="X()+-*/^EP";
  279.           (* ,1234,1234,1234,1234,1234,1234,1234,1234,1234,1234,1234,1234 *)
  280.   mehrfach:=" SIN  COS  TAN  LN   SQRT ABS  EXP  ATAN ASIN ACOS TANH SINH"+
  281.             " COSH RTOD DTOR SGN  FACT LOG  INT  ";
  282.   CapString (ex);
  283.   pos:=Length(ex);
  284.   WHILE ex[pos]=" " DO
  285.     ex[pos]:=0C; DEC (pos);
  286.   END;
  287.   pos:=0;
  288.   error:=noFehler; sym:=-1;
  289.   getch;  (* ex,pos,ch *)
  290.   IF ch#0C THEN
  291.     getsym; (* ex,pos,ch,sym,wert *)
  292.     y:=expression();
  293.   END;
  294.   IF error=noFehler THEN
  295.     IF sym=2 THEN error:=Klammerauf;
  296.     ELSIF (ch#0C) OR (sym#-1) THEN
  297.       error:=Fehler;
  298.     END;
  299.   END;
  300. END calcex;
  301.  
  302. END function.
  303.